home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / graphic / tpega.zip / KC-PAL.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-01  |  8KB  |  314 lines
  1. {                                                                              }
  2. {   Program:     PAL, Version 01/20/86                                         }
  3. {                                                                              }
  4. {   Description: This program gives the user the ability to change the         }
  5. {                palettes on the IBM's Enhanced Graphic Adapter.  This         }
  6. {                program works much better with 'KCSETPAL.COM' see doc.        }
  7. {                                                                              }
  8. {   Author:      Kent Cedola                                                   }
  9. {                2015 Meadow Lake Court, Norfolk VA, 23518. 1-(804)-857-0613   }
  10. {                                                                              }
  11. {   Language:    Turbo Pascal, V3.01A                                          }
  12. {                                                                              }
  13. {   Comments:    This program only includes the graphic routines needed to     }
  14. {                save space and time for BBS's.  If you would like a complete  }
  15. {                set of EGA graphic routines (FREE), please let me know.       }
  16. {                                                                              }
  17.  
  18. {$K- }
  19.  
  20. {$I GPParms.p }
  21. {$I GPInit.p  }
  22. {$I GPTerm.p  }
  23. {$I GPColor.p }
  24. {$I GPMerge.p }
  25. {$I GPPal.p   }
  26. {$I GPRdPal.p }
  27. {$I GPMOVE.P  }
  28. {$I GPLine.p  }
  29. {$I GPRect.p  }
  30. {$I GPBox.p   }
  31.  
  32. const
  33.   UP_ARROW    = #72;
  34.   DOWN_ARROW  = #80;
  35.   LEFT_ARROW  = #75;
  36.   RIGHT_ARROW = #77;
  37.  
  38. var
  39.   x,y,p,i: Integer;
  40.   x1,y1:   Integer;
  41.  
  42.   ch   : Char;
  43.  
  44.   pal:   array [0..7] of array [0..1] of Byte;
  45.  
  46. procedure InitGraphics;
  47. begin
  48.   GPParms;                              { Sets up all global variables  }
  49.  
  50.   if GDTYPE = 4 then                    { Give monochrome user bad news }
  51.     begin
  52.       writeln('Sorry, must have a Color Display not monochrome!');
  53.       halt(1);
  54.     end
  55.   else if GDTYPE <> 5 then              { Tell non-EGA users no can run }
  56.     begin
  57.       writeln('Enhanced Color Adapter and Display not found!');
  58.       halt(2);
  59.     end;
  60.  
  61.   if GDMEMORY = 64 then                 { We need lots of EGA memory    }
  62.     begin
  63.       writeln('This program will work much better with 128k+ EGA memory!');
  64.       writeln('    Hit any key to continue!');
  65.       Read(Kbd,Ch);
  66.    end;
  67.  
  68.   GPInit;                               { We are now in graphic mode!   }
  69.  
  70. end;
  71.  
  72. procedure TermGraphics;
  73. begin
  74.  
  75.   GPTerm;                               { Terminate graphic mode        }
  76.  
  77. end;
  78.  
  79. procedure TitlePage;
  80. begin
  81.  
  82.   GPColor(Black);
  83.   GPMOVE(0,0);
  84.   GPBox(GDMAXCOL,GDMAXROW);
  85.  
  86.   TextColor(Cyan);
  87.   gotoxy( 3, 2); write('KC-PAL 01/20/86');
  88.   gotoxy(27, 2); write('Set the palettes of IBM''s EGA');
  89.   gotoxy(68, 2); write('KC-GRAPHICS');
  90.  
  91.   for y := 0 to 1 do
  92.     for x := 0 to 7 do
  93.       begin
  94.         GPColor(y*8+x);
  95.         GPMOVE(x*72+32,139-y*61);
  96.         GPBox(x*72+103,199-y*61);
  97.         p := GPRdPal(y*8+x);
  98.         if p = -1 then
  99.           begin
  100.             pal[x,y] := y * 56 + x;
  101.             GPPal(y*8+x,y*56+x);
  102.           end
  103.         else
  104.           pal[x,y] := p;
  105.         GPColor(LightGray);
  106.         gotoxy(x*9+7,16-y*11); write('C# ',pal[x,y]:2);
  107.       end;
  108.  
  109.   GPColor(Green);
  110.   GPMOVE(0,0);
  111.   GPRect(639,349);
  112.   GPMOVE(4,3);
  113.   GPRect(635, 38);
  114.   GPMOVE(4,41);
  115.   GPRect(635,346);
  116.   GPMOVE(31,77);
  117.   GPRect(608,200);
  118.  
  119.   TextColor(LightGray);
  120.   gotoxy(19,18);
  121.   write('Palette Selected XX, Color XX, RGB = (X,X,X).');
  122.   gotoxy(11,20);
  123.   write('Use the arrow keys to select a palette.  Use +, -, R, G, B, or');
  124.   gotoxy(07,21);
  125.   write('numeric keys to change the current color. Hit the SPACE BAR to reset');
  126.   gotoxy(07,22);
  127.   write('the palettes to the their default values. Use the program KCSETPAL');
  128.   gotoxy(07,23);
  129.   write('to retain changes while using other programs. Hit the "ESC" key to');
  130.   gotoxy(07,24);
  131.   write('exit. Send comments (SASE) to 2015 Meadow Lake Ct., Norfolk VA 23518');
  132.  
  133. end;
  134.  
  135. procedure xoropt(X,Y: Integer);
  136. var
  137.   x1,y1: Integer;
  138. begin
  139.   x1 := x * 72 + 40;
  140.   y1 := 210 - y * 154;
  141.  
  142.   GPColor(Green);
  143.   GPMerge(3);
  144.   GPMOVE(x1,y1);
  145.   GPBox(x1+56,y1+14);
  146.   GPmerge(0);
  147. end;
  148.  
  149. procedure newcolor(x,y,c: Integer);
  150. begin
  151.   xoropt(x,y);
  152.  
  153.   TextColor(Cyan);
  154.   gotoxy(x*9+10,16-y*11); write(c:2);
  155.   gotoxy(46,18);          write(c:2);
  156.   gotoxy(36,18);          write(y*8+x:2);
  157.  
  158.   gotoxy(57,18); write(((c shr 4) and 2) or ((c shr 2) and 1):1);
  159.   gotoxy(59,18); write(((c shr 3) and 2) or ((c shr 1) and 1):1);
  160.   gotoxy(61,18); write(((c shr 2) and 2) or (c and 1):1);
  161.  
  162.   GPPal(y*8+x,c);
  163.   xoropt(x,y);
  164.  
  165. end;
  166.  
  167. begin { Main Line Code }
  168.  
  169.   InitGraphics;
  170.  
  171.   TitlePage;
  172.  
  173.   x := 0;
  174.   y := 0;
  175.  
  176.   xoropt(x,y);
  177.   newcolor(x,y,pal[x,y]);
  178.  
  179.   repeat
  180.     GPColor(Green);
  181.  
  182.     Read(Kbd,Ch);
  183.  
  184.     if (Ch = #27) and keypressed then
  185.       begin
  186.       Read(Kbd,Ch);
  187.       case Ch of
  188.         UP_ARROW:
  189.           begin
  190.             xoropt(x,y);
  191.             y := (y+1) mod 2;
  192.             xoropt(x,y);
  193.           end;
  194.  
  195.         LEFT_ARROW:
  196.           begin
  197.             xoropt(x,y);
  198.             x := (x + 7) mod 8;
  199.             xoropt(x,y);
  200.           end;
  201.  
  202.         RIGHT_ARROW:
  203.           begin
  204.             xoropt(x,y);
  205.             x := (x+1) mod 8;
  206.             xoropt(x,y);
  207.           end;
  208.  
  209.         DOWN_ARROW:
  210.           begin
  211.             xoropt(x,y);
  212.             y := (y+1) mod 2;
  213.             xoropt(x,y);
  214.           end;
  215.         end;
  216.       end
  217.     else
  218.       begin
  219.       case Ch of
  220.         '0'..'9':
  221.           begin
  222.             pal[x,y] := (pal[x,y] * 10) mod 100 + (ord(ch) - ord('0'));
  223.             if pal[x,y] > 63 then
  224.               pal[x,y] := pal[x,y] mod 10;
  225.           end;
  226.  
  227.         'R','r':
  228.           begin
  229.             i := (pal[x,y] shr 4 and 2 or pal[x,y] shr 2 and 1) + 1 and 3;
  230.             pal[x,y] := pal[x,y] and $1B or i and 2 shl 4 or i and 1 shl 2;
  231.           end;
  232.  
  233.         'G','g':
  234.           begin
  235.             i := (pal[x,y] shr 3 and 2 or pal[x,y] shr 1 and 1) + 1 and 3;
  236.             pal[x,y] := pal[x,y] and $2D or i and 2 shl 3 or i and 1 shl 1;
  237.           end;
  238.  
  239.         'B','b':
  240.           begin
  241.             i := (pal[x,y] shr 2 and 2 or pal[x,y] and 1 + 1) and 3;
  242.             pal[x,y] := pal[x,y] and $36 or i and 2 shl 2 or i and 1;
  243.           end;
  244.  
  245.         '+':
  246.           begin
  247.             pal[x,y] := (pal[x,y] + 1) mod 64;
  248.           end;
  249.  
  250.         '-':
  251.           begin
  252.             pal[x,y] := (pal[x,y] + 63) mod 64;
  253.           end;
  254.  
  255.         ' ':
  256.           begin
  257.             for y1 := 0 to 1 do
  258.               for x1 := 0 to 7 do
  259.                 begin
  260.                 pal[x1,y1] := y1 * 56 + x1;
  261.                 if (x <> x1) or (y <> y1) then
  262.                   begin
  263.                   GPPal(y1*8+x1,y1*56+x1);
  264.                   GPColor(LightGray);
  265.                   gotoxy(x1*9+10,16-y1*11); write(pal[x1,y1]:2);
  266.                   end;
  267.                 end;
  268.           end;
  269.         #27:
  270.           begin
  271.  
  272.           end;
  273.         else
  274.           write(chr(7));
  275.       end;
  276.     end;
  277.     newcolor(x,y,pal[x,y]);
  278.   until Ch = #27;
  279.  
  280.   TermGraphics;
  281.  
  282.   i := 0;
  283.   for y := 0 to 1 do
  284.     for x := 0 to 7 do
  285.       if pal[x,y] <> y*56+x then
  286.         begin
  287.         GPPal(y*8+x,pal[x,y]);
  288.         i := i + 1;
  289.         end;
  290.  
  291.   if i <> 0 then
  292.     begin
  293.     writeln('You can use the program "KCSETPAL" to set the palettes directly.');
  294.     writeln;
  295.     write('        KCSETPAL ');
  296.  
  297.     for y := 0 to 1 do
  298.       for x := 0 to 7 do
  299.         begin
  300.         if pal[x,y] <> y*56+x then
  301.           begin
  302.           write(pal[x,y]);
  303.           i := i - 1;
  304.           end;
  305.         if ((y <> 1) or (x <> 7)) and (i <> 0) then
  306.           begin
  307.           write(',');
  308.           end;
  309.         end;
  310.     writeln; writeln;
  311.     writeln('Put the above in your autoexec.bat file to set colors on boot!');
  312.     end;
  313. end.
  314.